home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 1.iso / desktop / mnyth2.zip / MANYTHNG.BAS next >
BASIC Source File  |  1994-02-17  |  10KB  |  237 lines
  1. ' ManyThng.BAS -- This is my attempt at a variable screen saver
  2. '   It is based on an example in "Learn Programming and Visual Basic 2.0"
  3. '   by John Socha and Sybex Inc., (highly recommended)
  4.  
  5. ' first written 4-15-93 Bruce McLean
  6. '
  7. Option Explicit
  8.  
  9. '
  10. ' These variables support saving the maximum number of lines
  11. ' in the CONTROL.INI file, which is where the Windows 3.1
  12. ' screen savers save setup information.
  13. '
  14. Global MaxLines As Integer      ' Lines to show before CLS
  15. Global RepeatCount As Integer   ' # of lines the same color
  16. Global MaxChangeMinutes As Single   ' minutes to go before changing color
  17. Global MaxCums As Integer      ' total number of lines before clearing screen
  18. Global BitmapsDir As String ' place to look for bitmaps
  19. Global BmpSeconds As Integer ' seconds between bitmaps on slide show
  20. Global RandomFlag As Integer ' non-zero means pick saver at random, else go in sequence
  21. Global StartSaver As Integer ' zero means pick 1st saver at random, else start with saver the corresponds to value
  22. Global ErrorTrace As Integer ' flag to log data for error tracing
  23. Global LowMemoryFlag As Integer 'set this to run special low memory mode
  24. Global TestMode As Integer 'this mode is for debugging code
  25.  
  26. Global Const iniName = "CONTROL.INI"
  27. Global Const secName = "Screen Saver.Many Things"
  28. Global Const keyName = "MaxLines"
  29. Global Const RepeatName = "RepeatCount"
  30. Global Const ChangeMinutesName = "MaxChangeMinutes"
  31. Global Const MaxCumsName = "MaxCumLines"
  32. Global Const BmpsDirName = "BitmapsDir"
  33. Global Const BmpSecondsName = "BmpSeconds"
  34. Global Const RandomFlagName = "RandomFlag"
  35. Global Const LowMemoryFlagName = "LowMemoryFlag"
  36. Global Const StartSaverName = "StartSaver"
  37. Global Const ErrorTraceName = "ErrorTrace"
  38.  
  39. ' windows defines
  40. Type RECT
  41.     left As Integer
  42.     top As Integer
  43.     right As Integer
  44.     bottom As Integer
  45. End Type
  46.  
  47. 'Polygon routine that draws any arbitray polygon using fill, etc.
  48. Type POINTAPI
  49.     X As Integer
  50.     Y As Integer
  51. End Type
  52.  
  53. ' Windows API Routines used:
  54. Declare Function ShowCursor Lib "USER" (ByVal fShow As Integer) As Integer
  55. Declare Sub BitBlt Lib "GDI" (ByVal DestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal BWidth As Integer, ByVal BHeight As Integer, ByVal SourceDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal Constant As Long)
  56. Declare Function StretchBlt Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal nSrcWidth As Integer, ByVal nSrcHeight As Integer, ByVal dwRop As Long) As Integer
  57. Declare Function CopyRect Lib "User" (lpDestRect As RECT, lpSourceRect As RECT) As Integer
  58. Declare Function CreateDC Lib "GDI" (ByVal Driver As Any, ByVal Dev As Any, ByVal O As Any, ByVal Init As Any) As Integer
  59. Declare Sub DeleteDC Lib "GDI" (ByVal hDC As Integer)
  60. Declare Sub DrawIcon Lib "User" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal hIcon As Integer)
  61. Declare Function GetCursor Lib "User" () As Integer
  62. Declare Sub GetCursorPos Lib "User" (lpPNT As Integer)
  63. Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
  64. Declare Function LockResource Lib "Kernel" (ByVal hRes As Integer) As Long
  65. Declare Sub UnlockResource Lib "Kernel" Alias "GlobalUnlock" (ByVal hRes As Integer)
  66. Declare Sub FloodFill Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal color As Long)
  67. Declare Function Polygon Lib "GDI" (ByVal hDC As Integer, lpPoints As POINTAPI, ByVal nCount As Integer) As Integer
  68. Declare Function SetPolyFillMode Lib "GDI" (ByVal hDC As Integer, ByVal nPolyFillMode As Integer) As Integer
  69. Declare Function GetNearestColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
  70. Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
  71. Declare Function SetSysModalWindow Lib "User" (ByVal hWND As Integer) As Integer
  72. 'routines for reading profile data in 'CONTROL.INI'
  73. Declare Function GetPrivateProfileInt Lib "KERNEL" (ByVal lpszSectionName As String, ByVal lpszKeyName As String, ByVal nDefault As Integer, ByVal lpszFileName As String) As Integer
  74. Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
  75. Declare Function WritePrivateProfileString Lib "KERNEL" (ByVal lpszSectionName As String, ByVal lpszKeyName As String, ByVal nString As String, ByVal lpszFileName As String) As Integer
  76. Declare Function SystemParametersInfo Lib "User" (ByVal uAction%, ByVal uParam%, lpvParam As Any, ByVal fuWinIni%) As Integer
  77.  
  78.  
  79. ' variables and constants to be used for screen capture
  80. Global ScrnWidth As Integer, ScrnHeight As Integer
  81. Dim RECT(3) As Integer
  82.  
  83. Global Const PI = 3.141592654
  84.  
  85. 'Device Parameters for GetDeviceCaps()
  86. Global Const DRIVERVERSION = 0  '  Device driver version
  87. Global Const TECHNOLOGY = 2 '  Device classification
  88. Global Const HORZSIZE = 4   '  Horizontal size in millimeters
  89. Global Const VERTSIZE = 6   '  Vertical size in millimeters
  90. Global Const HORZRES = 8    '  Horizontal width in pixels
  91. Global Const VERTRES = 10   '  Vertical width in pixels
  92. Global Const BITSPIXEL = 12 '  Number of bits per pixel
  93. Global Const PLANES = 14    '  Number of planes
  94. Global Const NUMBRUSHES = 16    '  Number of brushes the device has
  95. Global Const NUMPENS = 18   '  Number of pens the device has
  96. Global Const NUMMARKERS = 20    '  Number of markers the device has
  97. Global Const NUMFONTS = 22  '  Number of fonts the device has
  98. Global Const NUMCOLORS = 24 '  Number of colors the device supports
  99. Global Const PDEVICESIZE = 26   '  Size required for device descriptor
  100. Global Const CURVECAPS = 28 '  Curve capabilities
  101. Global Const LINECAPS = 30  '  Line capabilities
  102. Global Const POLYGONALCAPS = 32 '  Polygonal capabilities
  103. Global Const TEXTCAPS = 34  '  Text capabilities
  104. Global Const CLIPCAPS = 36  '  Clipping capabilities
  105. Global Const RASTERCAPS = 38    '  Bitblt capabilities
  106. Global Const ASPECTX = 40   '  Length of the X leg
  107. Global Const ASPECTY = 42   '  Length of the Y leg
  108. Global Const ASPECTXY = 44  '  Length of the hypotenuse
  109.  
  110. Global Const LOGPIXELSX = 88    '  Logical pixels/inch in X
  111. Global Const LOGPIXELSY = 90    '  Logical pixels/inch in Y
  112.  
  113. Global Const SIZEPALETTE = 104  '  Number of entries in physical palette
  114. Global Const NUMRESERVED = 106  '  Number of reserved entries in palette
  115. Global Const COLORRES = 108 '  Actual color resolution
  116.  
  117. Global Const SPI_SETSCREENSAVEACTIVE = 17
  118.  
  119. Sub EndScrnsave ()
  120.     Dim i As Integer
  121.  
  122.     ShowMouse                   ' Make mouse pointer visible again
  123.     LogFile ("ManyThng done")   ' make log
  124.  
  125.     'tell windows to enable screen savers
  126.     i = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, True, 0, 0)
  127.     End                         ' And exit
  128. End Sub
  129.  
  130. Sub HideMouse ()
  131.     While ShowCursor(False) >= 0
  132.     Wend
  133. End Sub
  134.  
  135. Sub LogFile (A As String)
  136.  
  137.   'to enable logging comment out next line
  138.   If Not ErrorTrace Then
  139.     Exit Sub
  140.   End If
  141.  
  142.   Open "c:\manythng.log" For Append Access Write As #1
  143.   Print #1, Date; "  "; Time; " "; A
  144.   Close #1
  145.  
  146. End Sub
  147.  
  148. Sub main ()
  149.     
  150.     Dim i As Integer
  151.     Dim DC As Integer
  152.     Dim temp As String
  153.     Dim temp2 As String * 128
  154.  
  155.     'see if error tracing is enabled
  156.     ' to enable, edit "control.ini" in windows directory
  157.     ' in section "[Screen Saver.Many Things]"
  158.     ' add line:  "ErrorTrace=ON"
  159.     ' to disable delete line
  160.     i = GetPrivateProfileString(secName, ErrorTraceName, "OFF", temp2, 125, iniName)
  161.     ErrorTrace = False ' default state
  162.     If UCase$(Left$(temp2, 2)) = "ON" Then
  163.       ErrorTrace = True ' default state
  164.     End If
  165.  
  166.     LogFile (Chr$(13) + Chr$(10) + "-----------------" + Chr$(13) + Chr$(10) + "Starting ManyThng")
  167.  
  168.     ' check if first instance of program so we can be sure that only one is running
  169.     If App.PrevInstance Then
  170.       LogFile ("Previous Instance of ManyThng")
  171.       EndScrnsave
  172.     End If
  173.  
  174.     ' first capture screen into Form 'Original' for later use
  175.     DC = CreateDC("DISPLAY", 0&, 0&, 0&)
  176.     ScrnWidth = GetDeviceCaps(DC, HORZRES)
  177.     ScrnHeight = GetDeviceCaps(DC, VERTRES)
  178.     BitBlt Original.hDC, 0, 0, ScrnWidth, ScrnHeight, DC, 0, 0, &HCC0020
  179.     DeleteDC DC
  180.  
  181.     '
  182.     ' This next lines of code get numbers from the CONTROL.INI
  183.     ' file in your Windows directory.
  184.     '
  185.     MaxLines = GetPrivateProfileInt(secName, keyName, 80, iniName)
  186.     RepeatCount = GetPrivateProfileInt(secName, RepeatName, 15, iniName)
  187.     i = GetPrivateProfileString(secName, ChangeMinutesName, "1", temp2, 125, iniName)
  188.     MaxChangeMinutes = Val(temp2)
  189.     MaxCums = GetPrivateProfileInt(secName, MaxCumsName, 400, iniName)
  190.     BmpSeconds = GetPrivateProfileInt(secName, BmpSecondsName, 5, iniName)
  191.     RandomFlag = GetPrivateProfileInt(secName, RandomFlagName, 1, iniName)
  192.     StartSaver = GetPrivateProfileInt(secName, StartSaverName, 0, iniName)
  193.     LowMemoryFlag = GetPrivateProfileInt(secName, LowMemoryFlagName, 0, iniName)
  194.  
  195.     ' get bitmaps directory
  196.     i = GetPrivateProfileString(secName, BmpsDirName, "c:\windows", temp2, 125, iniName)
  197.     BitmapsDir = ""
  198.     For i = 1 To Len(temp2)' remove trailing whatevers from dir
  199.       temp = Mid$(temp2, i, 1)
  200.       If Asc(temp) <= 32 Or Asc(temp) > 126 Then GoTo done
  201.       BitmapsDir = BitmapsDir + temp
  202.     Next i
  203. done:
  204.     
  205.       
  206.     'look for test mode, used when debugging in VisBasic
  207.     If InStr(Command$, "/t") Then
  208.       TestMode = 1
  209.     Else
  210.       TestMode = 0
  211.     End If
  212.  
  213.     ' Check to see if we should blank the screen, or display
  214.     ' the Setup dialog box.
  215.     '
  216.     If InStr(Command$, "/c") Then
  217.     LogFile ("Configuring ManyThng")
  218.     SetupForm.Show 1
  219.     ElseIf InStr(Command$, "/s") Then
  220.     LogFile ("Running ManyThng")
  221.     ManyThings.Show
  222.     End If
  223.  
  224.     '
  225.     ' Wait until there are no forms visible, then quit.
  226.     '
  227.     While DoEvents() > 0        ' Loop until no forms visible
  228.     Wend
  229.     
  230. End Sub
  231.  
  232. Sub ShowMouse ()
  233.     While ShowCursor(True) < 0
  234.     Wend
  235. End Sub
  236.  
  237.